home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / stk-3.002 / stk-3 / STk-3.1 / Lib / unix.stk < prev   
Encoding:
Text File  |  1996-02-22  |  2.3 KB  |  76 lines
  1. ;;;;
  2. ;;;; u n i x  . s t k            -- Some unix stuff
  3. ;;;;
  4. ;;;; Copyright ⌐ 1993-1996 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
  5. ;;;; 
  6. ;;;; Permission to use, copy, and/or distribute this software and its
  7. ;;;; documentation for any purpose and without fee is hereby granted, provided
  8. ;;;; that both the above copyright notice and this permission notice appear in
  9. ;;;; all copies and derived works.  Fees for distribution or use of this
  10. ;;;; software or derived works may only be charged with express written
  11. ;;;; permission of the copyright holder.  
  12. ;;;; This software is provided ``as is'' without express or implied warranty.
  13. ;;;;
  14. ;;;;           Author: Erick Gallesio [eg@kaolin.unice.fr]
  15. ;;;;    Creation date: 29-Mar-1994 17:36
  16. ;;;; Last file update:  7-Nov-1995 10:51
  17. ;;;;
  18.  
  19. ;;;; This file implements
  20. ;;;;    (basename f)        
  21. ;;;;    (dirname f)
  22. ;;;;    (decompose-file-name f)        return f expoded in a list
  23. ;;;;    (file-is-directory?  f)
  24. ;;;;    (file-is-regular?    f)
  25. ;;;;    (file-is-readable?   f)
  26. ;;;;    (file-is-writable?   f)
  27.  
  28.  
  29. (define basename         '())
  30. (define dirname          '())
  31. (define decompose-file-name '())
  32.  
  33.  
  34. (let ()
  35.   (define (delete-trailing-slashes s)
  36.     (let ((pos (- (string-length s) 1)))
  37.       (while (and (>= pos 0) (char=? (string-ref s pos) #\/)) 
  38.          (set! pos (- pos 1)))
  39.       (if (= pos -1)
  40.       "/"
  41.       (substring s 0 (+ pos 1)))))
  42.  
  43.   (define (decompose name)
  44.     (if (equal? name "/")
  45.     (cons "/" "")
  46.     (begin
  47.       (let* ((f    (delete-trailing-slashes name))
  48.              (len  (string-length f))
  49.          (pos  (- len 1)))         
  50.         
  51.         ;; find last slash
  52.         (while (and (>= pos 0) (not (char=? (string-ref f pos) #\/)))
  53.            (set! pos (- pos 1)))
  54.  
  55.         (case pos
  56.           (-1   (cons "." (substring f 0 len)))
  57.           (0    (cons "/" (substring f 1 len)))
  58.           (else (cons (delete-trailing-slashes (substring f 0 pos))
  59.               (substring f (+ pos 1) len))))))))
  60.  
  61.  
  62.   (set! basename         (lambda (file) (cdr (decompose file))))
  63.   (set! dirname          (lambda (file) (car (decompose file))))
  64.   (set! decompose-file-name (lambda (file) 
  65.                   (letrec ((decomp (lambda (file res)
  66.                          (if (or (equal? file "/")
  67.                              (equal? file "."))
  68.                              (cons file res)
  69.                              (let ((r (decompose file)))
  70.                                (decomp (car r)
  71.                                    (cons (cdr r)
  72.                                       res)))))))
  73.                 (decomp file '())))))
  74.  
  75. (provide "unix")
  76.